;;;; Roguelib copyright 2010 Adam White (theroguemonkey@gmail.com)
;;;; Licensed under GNU General Public Licence v2 or later - refer COPYING

(in-package #:rllib)


(cffi:defcfun ("SDL_RWFromFile" %sdl-rw-from-file) :pointer
  (file :string)
  (mode :string))

(cffi:defcstruct %sdl-pixel-format
  (palette :pointer)
  (bits-per-pixel :uint8)
  (bytes-per-pixel :uint8)
  (rloss :uint8)
  (gloss :uint8)
  (bloss :uint8)
  (aloss :uint8)
  (rshift :uint8)
  (gshift :uint8)
  (bshift :uint8)
  (ashift :uint8)
  (rmask :uint32)
  (gmask :uint32)
  (bmask :uint32)
  (amask :uint32)
  (colorkey :uint32)
  (alpha :uint8))


;;;;============================================================================
;;;; Rects
;;;;============================================================================

(cffi:defcstruct %sdl-rect
  (x :int16)
  (y :int16)
  (w :uint16)
  (h :uint16))

(defclass sdl-rect ()
  ((x :initform 0 :initarg :x :accessor sdl-rect-x)
   (y :initform 0 :initarg :y :accessor sdl-rect-y)
   (w :initform 9 :initarg :w :accessor sdl-rect-w)
   (h :initform 9 :initarg :h :accessor sdl-rect-h)))

(defun make-sdl-rect (x y w h)
  (make-instance 'sdl-rect :x x :y y :w w :h h))

(defun sdl-rect->%sdl-rect (rect)
  (let ((r (cffi:foreign-alloc '%sdl-rect)))
    (setf (cffi:foreign-slot-value r '%sdl-rect 'x) (sdl-rect-x rect)
	  (cffi:foreign-slot-value r '%sdl-rect 'y) (sdl-rect-y rect)
	  (cffi:foreign-slot-value r '%sdl-rect 'w) (sdl-rect-w rect)
	  (cffi:foreign-slot-value r '%sdl-rect 'h) (sdl-rect-h rect))
    r))

(defmacro with-sdl-rect ((name x y w h) &body body)
  `(cffi:with-foreign-object (,name '%sdl-rect)
     (setf (cffi:foreign-slot-value ,name '%sdl-rect 'x) ,x
	   (cffi:foreign-slot-value ,name '%sdl-rect 'y) ,y
	   (cffi:foreign-slot-value ,name '%sdl-rect 'w) ,w
	   (cffi:foreign-slot-value ,name '%sdl-rect 'h) ,h)
     ,@body))

(defmacro with-sdl-rect* ((name rect) &body body)
  `(cffi:with-foreign-object (,name '%sdl-rect)
     (setf (cffi:foreign-slot-value ,name '%sdl-rect 'x) (sdl-rect-x ,rect)
	   (cffi:foreign-slot-value ,name '%sdl-rect 'y) (sdl-rect-y ,rect)
	   (cffi:foreign-slot-value ,name '%sdl-rect 'w) (sdl-rect-w ,rect)
	   (cffi:foreign-slot-value ,name '%sdl-rect 'h) (sdl-rect-h ,rect))
     ,@body))


;;;;============================================================================
;;;; Surfaces
;;;;;============================================================================

(cffi:defcstruct %sdl-surface
  (flags :uint32)
  (format :pointer)
  (w :int)
  (h :int)
  (pitch :uint16)
  (pixels :pointer)
  (offset :int)
  (hwdata :pointer)
  (clip-rect %sdl-rect)
  (unused1 :uint32)
  (locked :uint32)
  (map :pointer)
  (version :uint)
  (refcount :int))

(defun %debug-dump-sdl-format (format)
  (dolist (i '(palette bits-per-pixel bytes-per-pixel rloss gloss bloss aloss rshift gshift bshift
	       ashift rmask gmask bmask amask colorkey alpha))
    (format t "~A = ~A~%" i (cffi:foreign-slot-value format '%sdl-pixel-format i))))

(defun %debug-dump-sdl-surface (surface)
  (dolist (i '(flags w h pitch pixels offset hwdata clip-rect unused1 locked map version refcount))
    (format t "~A = ~A~%" i (cffi:foreign-slot-value surface '%sdl-surface i)))
  (%debug-dump-sdl-format (cffi:foreign-slot-value surface '%sdl-surface 'format)))

(defun sdl-surface-pixels (surface)
  (cffi:foreign-slot-value surface '%sdl-surface 'pixels))

(defun sdl-surface-pixel-bpp (surface)
  (cffi:foreign-slot-value (cffi:foreign-slot-value surface '%sdl-surface 'format)
			   '%sdl-pixel-format
			   'bytes-per-pixel))

(defun sdl-surface-w (surface)
  (cffi:foreign-slot-value surface '%sdl-surface 'w))

(defun sdl-surface-h (surface)
  (cffi:foreign-slot-value surface '%sdl-surface 'h))

(cffi:defcfun ("SDL_ConvertSurface" sdl-convert-surface) %sdl-surface
  (source %sdl-surface)
  (pixel-format %sdl-pixel-format)
  (flags :uint32))

(cffi:defcfun ("SDL_CreateRGBSurface" sdl-create-rgb-surface) %sdl-surface
  (flags sdl-video-mode-flags)
  (width :int)
  (height :int)
  (depth :int)
  (rmask :uint32)
  (gmask :uint32)
  (bmask :uint32)
  (amask :uint32))

(cffi:defcfun ("SDL_CreateRGBSurfaceFrom" sdl-create-rgb-surface-from) %sdl-surface
  (pixels :pointer)
  (flags sdl-video-mode-flags)
  (width :int)
  (height :int)
  (depth :int)
  (rmask :uint32)
  (gmask :uint32)
  (bmask :uint32)
  (amask :uint32))

(cffi:defcfun ("C_SDL_CreateRGBSurface" sdl-create-surface) %sdl-surface
  (width :int)
  (height :int))

(cffi:defcfun ("SDL_FreeSurface" sdl-free-surface) :void
  (surface %sdl-surface))

(cffi:defcfun ("SDL_LockSurface" sdl-lock-surface) :int
  (surface %sdl-surface))

(cffi:defcfun ("SDL_UnlockSurface" sdl-unlock-surface) :void
  (surface %sdl-surface))

(defmacro with-sdl-locked-surface (surface &body body)
  `(unwind-protect
    (progn
      (sdl-lock-surface ,surface)
      ,@body)
    (sdl-unlock-surface ,surface)))

(defmacro with-sdl-surface ((name initialiser) &body body)
  `(let ((,name ,initialiser))
     (unwind-protect
	  (progn
	    ,@body)
       (sdl-free-surface ,name))))

(defmacro with-sdl-surface* ((name width height) &body body)
  `(with-sdl-surface (,name (sdl-create-surface ,width ,height))
     ,@body))

;;;;============================================================================
;;;; Colour
;;;;============================================================================

(cffi:defcstruct %sdl-color
  (r :uint8)
  (g :uint8)
  (b :uint8)
  (unused :uint8))

(cffi:defcfun ("SDL_MapRGB" %sdl-map-rgb) :uint32
  (format :pointer)
  (r :uint8)
  (g :uint8)
  (b :uint8))

(cffi:defcfun ("SDL_MapRGBA" %sdl-map-rgba) :uint32
  (format %sdl-pixel-format)
  (r :uint8)
  (g :uint8)
  (b :uint8)
  (a :uint8))

(defgeneric colour->rgb (color)
  (:method ((color colour))
    (%sdl-map-rgb (cffi:foreign-slot-value *screen* '%sdl-surface 'format)
		  (colour-r color) (colour-g color) (colour-b color)))
  (:method (color)
    (%sdl-map-rgb (cffi:foreign-slot-value *screen* '%sdl-surface 'format)
		  (cffi:foreign-slot-value color '%sdl-color 'r)
		  (cffi:foreign-slot-value color '%sdl-color 'g)
		  (cffi:foreign-slot-value color '%sdl-color 'b))))

(defmacro with-color ((name colour) &body body)
  `(cffi:with-foreign-object (,name '%sdl-color)
     (setf (cffi:foreign-slot-value ,name '%sdl-color 'r) (colour-r ,colour)
	   (cffi:foreign-slot-value ,name '%sdl-color 'g) (colour-g ,colour)
	   (cffi:foreign-slot-value ,name '%sdl-color 'b) (colour-b ,colour))
     ,@body))


(cffi:defcfun ("SDL_FillRect" %sdl-fill-rect) :int
  (dst %sdl-surface)
  (dstrect %sdl-rect)
  (color :uint32))

(defgeneric sdl-fill-rect (surface rect color)
  (:method ((surface null) rect color)
    (sdl-fill-rect *screen* rect color))
  (:method (surface rect (color colour))
    (sdl-fill-rect surface rect (colour->rgb color)))
  (:method (surface (rect null) color)
    (sdl-fill-rect surface (cffi:null-pointer) color))
  (:method (surface (rect sdl-rect) color)
    (with-sdl-rect* (fill rect)
      (sdl-fill-rect surface fill color)))
  (:method (surface rect (color integer))
    (%sdl-fill-rect surface rect color)))

;;;============================================================================
;;; Video
;;;============================================================================

(defconstant +sdl-alpha-opaque+ 255)
(defconstant +sdl-alpha-transparent+ 0)




(cffi:defcfun ("SDL_VideoInit" sdl-video-init) :boolean
  (driver-name :string)
  (flags sdl-video-mode-flags))

(cffi:defcfun ("SDL_VideoQuit" sdl-video-quit) :void)


(cffi:defcfun ("SDL_UpdateRect" %sdl-update-rect) :void
  (screen %sdl-surface)
  (x :int32)
  (y :int32)
  (w :int32)
  (h :int32))

(defun sdl-update (x y w h)
  (%sdl-update-rect (sdl-get-video-surface) x y w h))



(cffi:defbitfield sdl-colorkey/alpha-flags
  (:clear #x00)
  (:srccolorkey #x1000)
  (:rleaccel #x4000)
  (:srcalpha #x10000))

(cffi:defcfun ("SDL_SetColorKey" %sdl-set-color-key) :int
  (surface %sdl-surface)
  (flags sdl-colorkey/alpha-flags)
  (key :uint32))

(defgeneric sdl-set-color-key (surface color)
  (:method (surface (color colour))
    (sdl-set-color-key surface (colour->rgb color)))
  (:method (surface (color integer))
    (%sdl-set-color-key (or surface *screen*) '(:srccolorkey :rleaccel) color)))

(cffi:defcfun ("SDL_SetAlpha" sdl-set-alpha) :int
  (surface %sdl-surface)
  (flags sdl-colorkey/alpha-flags)
  (alpha :uint8))

(cffi:defcfun ("SDL_SetClipRect" %sdl-set-clip-rect) :boolean
  (surface %sdl-surface)
  (rect %sdl-rect))

(defgeneric (setf sdl-clip-rect) (rect surface)
  (:method ((rect sdl-rect) surface)
    (sdl-clip-rect (sdl-rect->%sdl-rect rect) surface))
  (:method ((rect null) surface)
    (sdl-clip-rect (cffi::null-pointer) surface))
  (:method (rect surface)
    (%sdl-set-clip-rect surface rect))) 

(cffi:defcfun ("SDL_GetClipRect" sdl-clip-rect) :void
  (surface %sdl-surface)
  (rect %sdl-rect))

(cffi:defcfun ("SDL_UpperBlit" %sdl-blit) :int
  (src %sdl-surface)
  (srcrect %sdl-rect)
  (dst %sdl-surface)
  (dstrect %sdl-rect))

(defgeneric sdl-blit (src srcrect dst dstrect)
  (:method (src (srcrect sdl-rect) dst dstrect)
    (with-sdl-rect* (srcrect2 srcrect)
      (sdl-blit src srcrect2 dst dstrect)))
  (:method (src (srcrect sdl-rect) dst (dstrect sdl-rect))
    (with-sdl-rect* (srcrect2 srcrect)
      (with-sdl-rect* (dstrect2 dstrect)
	(%sdl-blit src srcrect2 dst dstrect2))))
  (:method (src srcrect dst (dstrect sdl-rect))
    (with-sdl-rect* (dstrect2 dstrect)
      (sdl-blit src srcrect dst dstrect2)))
  (:method (src srcrect dst dstrect)
    (%sdl-blit (or src *screen*)
	       (or srcrect (cffi:null-pointer)) 
	       (or dst *screen*)
	       (or dstrect (cffi:null-pointer)))))


;;;;============================================================================
;;;; Specialisations for SDL
;;;;============================================================================

(defmethod init-graphics ((type (eql :sdl)))
  (sdl-init '(:init-video :init-audio))
  (ttf-init))

(defmethod quit-graphics ((type (eql :sdl)))
  (ttf-quit)
  (sdl-quit))

(defclass sdl-panel (panel)
 ((rect
   :initarg :rect
   :accessor sdl-panel-rect)))

(defclass ttf-font (font)
  ((font
    :initarg :font
    :accessor ttf-font)))

(defclass sdl-image (image)
  ((surface
    :initarg :image
    :reader sdl-image)))


(defmethod make-panel ((type (eql :sdl)) x y w h)
  (let ((panel (make-instance 'sdl-panel :x x :y y :w w :h h :rect (make-sdl-rect x y w h)) ))
      (tg:finalize panel (lambda () (cffi:foreign-free (sdl-panel-rect panel))))))

(defmethod set-clipping ((panel sdl-panel))
  (setf (sdl-clip-rect *screen*) (sdl-panel-rect panel)))

(defmethod clear-clipping ((panel sdl-panel))
  (setf (sdl-clip-rect *screen*) nil))

(defmethod load-font ((type (eql :sdl)) subpathname size)
  (let ((font (make-instance 'ttf-font :font (ttf-open (path->file subpathname) size) :size size)))
    (tg:finalize font (lambda () (ttf-close font)))))

(defmethod font-width ((font ttf-font) string)
  (ttf-width-utf8 font string))

(defmethod font-height ((font ttf-font))
  (ttf-line-skip font))

(defmethod output-single-text ((panel sdl-panel) (font ttf-font) text colour x y)
  (with-sdl-surface (line (ttf-render-utf8-blended font text colour))
    (with-sdl-rect (dst x y (sdl-surface-w line) (sdl-surface-h line))
      (sdl-blit line nil *screen* dst))))

(defmethod load-image ((type (eql :sdl)) subpathname)
  (let ((image (make-instance 'sdl-image :image (img-load (path->file subpathname)))))
    (tg:finalize image (lambda () (sdl-free-surface image)))))

(defmethod output-image ((image sdl-image) x y)
  (with-sdl-rect (dst x y (image-w image) (image-h image))
    (sdl-blit (sdl-image image) nil *screen* dst)))

(defmethod output-colour ((panel sdl-panel) x y w h colour alpha)
  (with-sdl-rect (dst x y w h)
    (sdl-fill-rect *screen* dst colour)))

(defmethod clear-screen ((type (eql :sdl)))
  (sdl-fill-rect *screen* nil +black+))

(defmethod update-screen ((type (eql :sdl)))
  (sdl-update 0 0 0 0))

